package Judge;
use warnings;
use strict;

# user modules
use SimpleError;

our %OP = (
#### strings
    's_eq'    => +{ code => sub { $_[0] eq $_[1]; },         desc => 'STR == %s',           },
    's_eq_ic' => +{ code => sub { uc($_[0]) eq uc($_[1]); }, desc => 'STR == %s (no-case)', },
    's_ne'    => +{ code => sub { $_[0] ne $_[1]; },         desc => 'STR != %s',           },
    's_ne_ic' => +{ code => sub { uc($_[0]) ne uc($_[1]); }, desc => 'STR != %s (no-case)', },

#### numeric
    # one operand
    'n_eq'    => +{ code => sub { $_[0] == $_[1]; }, desc => 'VAL == %g', },
    'n_ne'    => +{ code => sub { $_[0] != $_[1]; }, desc => 'VAL != %g', },
    'n_lt'    => +{ code => sub { $_[0] <  $_[1]; }, desc => 'VAL <  %g', },
    'n_le'    => +{ code => sub { $_[0] <= $_[1]; }, desc => 'VAL <= %g', },
    'n_gt'    => +{ code => sub { $_[0]  > $_[1]; }, desc => 'VAL  > %g', },
    'n_ge'    => +{ code => sub { $_[0] >= $_[1]; }, desc => 'VAL >= %g', },
    # two operands, inclusive
    'n_ge_le' => +{ code => sub { $_[1] <= $_[0] && $_[0] <= $_[2]; }, desc => '%g <= VAL <= %g', },
    'n_gt_le' => +{ code => sub { $_[1] <  $_[0] && $_[0] <= $_[2]; }, desc => '%g <  VAL <= %g', },
    'n_ge_lt' => +{ code => sub { $_[1] <= $_[0] && $_[0] <  $_[2]; }, desc => '%g <= VAL <  %g', },
    'n_gt_lt' => +{ code => sub { $_[1] <  $_[0] && $_[0] <  $_[2]; }, desc => '%g <  VAL <  %g', },
    # two operands, exclusive
    'n_le_ge' => +{ code => sub { $_[0] <= $_[1] || $_[0] >= $_[2]; }, desc => 'VAL <= %g or VAL >= %g', },
    'n_lt_ge' => +{ code => sub { $_[0] <  $_[1] || $_[0] >= $_[2]; }, desc => 'VAL <  %g or VAL >= %g', },
    'n_le_gt' => +{ code => sub { $_[0] <= $_[1] || $_[0] >  $_[2]; }, desc => 'VAL <= %g or VAL >  %g', },
    'n_lt_gt' => +{ code => sub { $_[0] <  $_[1] || $_[0] >  $_[2]; }, desc => 'VAL <  %g or VAL >  %g', },
);

## new: object creation
## input: the specs, which is a reference to an array of array references,
##        for detail, see example script 'yield-repository.pl'
## output: the judge object, which is immutable
sub new {
    my $class = shift;
    my $specs = shift;
    error("Invalid specs for Judge") unless (defined($specs) && check_specs($specs));
    ## $limits is an optimzed-for-running data structure of $specs
    my $limits = make_limits($specs);
    ## $self->{Result} stores the last IC's judge result,
    ## for each limit, 1 for pass, 0 for fail, and the last element
    ## designates the overall result of a single IC.
    ## this array ref is returned by 'judge_ic', you should use the result
    ## immediately because it will be overwritten each time a new judge
    ## is executed (hopefully this could be somewhat more efficient, if not,
    ## create a new array each time for safety)
    my $result = [ map(undef, 0 .. scalar(@$limits)) ]; # one more than the length of @$limits
    my $self = +{ Specs => $specs, Limits => $limits, Result => $result };
    bless $self, $class;
    return $self;
}

sub judge_ic {
    my $self = shift;
    my ($ic) = @_;
    my $pass_fail = 1;
    for my $i (0 .. $#{$self->{Limits}}) {
        my $limit = $self->{Limits}[$i];
        # $limit: [0]: the data item (string or code ref)
        #         [1]: the comparing method (code ref)
        #         [2]: the operands (array ref)
        my $test_value = ref($limit->[0]) eq 'CODE' ? $limit->[0]->($ic)
            : $ic->{$limit->[0]};
        if ($limit->[1]->($test_value, @{$limit->[2]})) {
            $self->{Result}[$i] = 1;
        } else {
            $self->{Result}[$i] = 0;
            $pass_fail = 0;
        }
    }
    $self->{Result}[ $#{$self->{Result}} ] = $pass_fail;
    return $self->{Result};
}

sub describe {
    my $self = shift;
    my @ret;
    for (@{ $self->{Specs} }) {
        my $bin_no     = $_->[0];
        my $data_item  = $_->[1];
        my $method     = $_->[2];
        my $desc_templ = $OP{$method}{desc};
        my $desc_str   = sprintf($desc_templ, @{$_}[3 .. $#$_]);
        my $data_name  = ref($data_item) eq 'ARRAY' ? $data_item->[0] : $data_item;
        push @ret, [$data_name, $bin_no, $desc_str];
    }
    return \@ret;
}

## class method
sub check_specs {
    my ($s) = @_;
    return 0 unless (ref($s) eq 'ARRAY');
    for my $item (@$s) {
        error("item $item: not an array ref") unless (ref($item) eq 'ARRAY');
        my ($bin_no, $test_item, $method, @operands) = @$item;
        error("$method: undefined method") unless (defined($OP{$method}));
        # count of operands for the comparing method
        my $op_count = ( ) = $OP{$method}{desc} =~ /%[gs]/go;
        error("$method: operands error") unless ($op_count == @operands);
        if (ref($test_item) eq 'ARRAY') {
            error("$test_item->[0]: not a valid code ref") unless (ref($test_item->[1]) eq 'CODE');
        }
    }
    return 1;
}

## class method
sub make_limits {
    my ($specs) = @_;
    my $limits = [ ];
    for my $s (@$specs) {
        my $data_item;
        if (ref($s->[1]) eq 'ARRAY') {
            $data_item = $s->[1][1]; # a code ref
        } else {
            $data_item = $s->[1];    # just an item name
        }
        push @$limits, [
            $s->[0],                 # the bin number [0]
            $data_item,              # the data item  [1]
            $OP{$s->[2]}{code},      # the operator   [2]
            [ @{$s}[3 .. $#s] ]      # the operands   [3]
        ];
    }
    return $limits;
}

## returning
1;
